home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / big_util.t < prev    next >
Text File  |  1988-02-05  |  5KB  |  151 lines
  1. (herald big_util
  2.   (env tsys (osys fixnum) bignum))
  3.  
  4. ;;; Low level bignum stuff
  5.  
  6. ;;; (MAKE-BIGNUM <number of slots>)
  7. (define (make-bignum length)
  8.   (make-vector-extend header/bignum
  9.                      (enforce acceptable-vector-size? length)
  10.                      length))
  11.  
  12. (lset *bignum-cons-counter* 0)
  13. (lset *bignum-cons-size-counter* 0)
  14.  
  15. (define (create-bignum j)
  16.   (set *bignum-cons-counter* (fx+ *bignum-cons-counter* 1))
  17.   (set *bignum-cons-size-counter* (fx+ *bignum-cons-size-counter* j))
  18.   (make-bignum j))
  19.  
  20. (define-integrable (bignum-sign num)
  21.   (if (bignum-positive? num) 1 -1))
  22.  
  23. (define-integrable (set-bignum-sign! num sign)
  24.   (if (if (bignum-positive? num)
  25.           (fx> 0 sign)
  26.           (fx< 0 sign))
  27.       (bignum-negate! num))
  28.   num)
  29.  
  30. ;;; Random general utilities:
  31.  
  32. (define (make-and-replace-bignum size old i1 i2 count)
  33.   (let ((new (create-bignum size)))
  34.     (do ((i 0 (fx+ i 1)))
  35.         ((fx>= i count)
  36.          (set-bignum-sign! new (bignum-sign old))
  37.          new)
  38.       (set (bignum-digit new (fx+ i1 i)) (bignum-digit old (fx+ i2 i))))))
  39.  
  40. (define (copy-bignum old)
  41.   (let* ((len (bignum-length old))
  42.          (new (make-and-replace-bignum len old 0 0 len)))
  43.     (set-bignum-sign! new (bignum-sign old))
  44.     new))
  45.  
  46. ;;; Given a bignum of length at least l, truncates that bignum,
  47. ;;; eliminating the leading zeros.  This is destructive.
  48.  
  49. (define (bignum-trim! num)
  50.   (do ((i (fx- (bignum-length num) 1) (fx- i 1)))
  51.       ((or (fx<= i 0)
  52.            (not (fx= (bignum-digit num i) 0)))
  53.        (set-bignum-length! num (fx+ i 1))
  54.        num)))
  55.  
  56. ;;; Primops for bignums
  57.  
  58. ;;; (BIGNUM-POSITIVE? <bignum>)
  59. ;;; (BIGNUM-NEGATE! <bignum>)
  60. ;;; (BIGNUM-LENGTH <bignum>)
  61. ;;; (SET-BIGNUM-LENGTH! <bignum> <length>)
  62.  
  63. ;;; Primops for 30 bit hyperdigits
  64.  
  65. ;;; Add two hyperdigits and a carry bit, returning sum and new carry.
  66.  
  67. (define (%digit-add u v carry)
  68.   (let ((sum (fx+ (fx+ (low-bits u) (low-bits v)) carry)))
  69.     (xcase (fx+ (high-bit u) (high-bit v))
  70.       ((0) (return sum 0))
  71.       ((1) (if (fx= (high-bit sum) 0)
  72.                (return (set-high-bit sum 1) 0)
  73.                (return (set-high-bit sum 0) 1)))
  74.       ((2) (return sum 1)))))
  75.  
  76. (define-integrable (high-bit x)
  77.   (fixnum-bit-field x 29 1))
  78.  
  79. (define-integrable (set-high-bit x b)
  80.   (set-fixnum-bit-field x 29 1 b))
  81.  
  82. (define-integrable (low-bits x)
  83.   (fixnum-bit-field x 0 29))
  84.  
  85. ;;; Subtract two hyperdigits and carry, returning difference and new carry.
  86.  
  87. (define (%digit-subtract u v carry)
  88.   (let ((sum (fx- (fx- (low-bits u) (low-bits v)) carry)))
  89.     (xcase (fx- (high-bit u) (high-bit v))
  90.       ((-1) (if (fx= (high-bit sum) 0)
  91.                (return (set-high-bit sum 1) 1)
  92.                (return (set-high-bit sum 0) 1)))
  93.       ((0) (return sum (high-bit sum)))
  94.       ((1) (if (fx= (high-bit sum) 0)
  95.                (return (set-high-bit sum 1) 0)
  96.                (return (set-high-bit sum 0) 0))))))
  97.  
  98. ;;; Multiply two hyperdigits, returning low and high digits of product.
  99.  
  100. (define (%digit-multiply u v)
  101.   (let ((low-u (low-half u))
  102.         (low-v (low-half v))
  103.         (high-u (high-half u))
  104.         (high-v (high-half v)))
  105.     (let ((low (fx* low-u low-v))
  106.           (middle-a (fx* low-u high-v))
  107.           (middle-b (fx* high-u low-v))
  108.           (high (fx* high-u high-v)))
  109.       (receive (low c1)
  110.                (%digit-add low (fixnum-ashl middle-a 15) 0)
  111.         (receive (low c2)
  112.                  (%digit-add low (fixnum-ashl middle-b 15) 0)
  113.           (receive (high #f)
  114.                    (%digit-add high
  115.                                (fx+ (fx+ (high-half middle-a)
  116.                                          (high-half middle-b))
  117.                                     c1)
  118.                                c2)
  119.             (return high low)))))))
  120.  
  121. (define-integrable (low-half x)
  122.   (fixnum-bit-field x 0 15))
  123.  
  124. (define-integrable (high-half x)
  125.   (fixnum-bit-field x 15 15))
  126.  
  127. (define-integrable (fixnum-lshr x d)
  128.   (fixnum-logand (fixnum-lognot (fixnum-ashl -1 (fx- 30 d)))
  129.                  (fixnum-ashr x d)))
  130.  
  131. (define (%digit-greater? x y)
  132.   (receive (dort carry)
  133.            (%digit-subtract y x 0)
  134.     (fx= carry 1)))
  135.  
  136. (define (fixnum-add-with-overflow-xxx x y)
  137.   (let ((sum (fx+ x y)))
  138.     (return sum (if (fx>= x 0)
  139.                     (and (fx> y 0) (fx< sum 0))
  140.                     (and (fx< y 0) (fx>= sum 0))))))
  141.  
  142. (define (fixnum-subtract-with-overflow-xxx x y)
  143.   (let ((diff (fx- x y)))
  144.     (return diff
  145.             (if (fx>= x 0)
  146.                 (and (fx< y 0) (fx< diff 0))
  147.                 (and (fx> y 0) (fx> diff 0))))))
  148.  
  149.  
  150.  
  151.